Developer CD Series 1994 August: Tool Chest/Dev.CD Aug 94.toast/Tool Chest/Development Platforms/Macintosh Common Lisp Related/User Contributions/mapforms (code walker).sea/mapforms (code walker)/mapforms.lisp

Text File | 1992-04-21 | 48.6 KB | 1,099 lines | [TEXT/CCL2]

;;; -*- Mode:LISP; Package:Language-Tools; Syntax:Common-Lisp -*-
;;;>>SHARED-MESSAGE
;;;>
;;;>******************************************************************************************
;;;>    This may only be used as permitted under the license agreement under
;;;>    which it has been distributed, and in no other way.
;;;>******************************************************************************************
;;;>
;;;>
;;; Written May 1982 by David A. Moon for use by the Common Lisp community
;;; Revised April 1983

;;; Tools for source code analysis: code-walker

;--- Common Lisp version conversion issues:
;--- new DECLARE not hacked yet
;--- Doesn't handle lexically-enclosed functions and macros yet
;--- use Common Lisp condition system to signal errors, when it has one
;--- BLOCK has to be processed in a very funny way?  See (RETURN MAPFORMS)
;--- Certain symbols, e.g. SYMEVAL, aren't CL function names any more
;--- Uses extended DEFUN syntax for defining functions as properties
;--- Depends on having LOOP of course

;;; Interface definitions

;; All symbols that are part of the interface are exported from the LT package

(EXPORT '(MAPFORMS COPYFORMS MAPFORMS-1 COPYFORMS-1            ;Functions
      CALL BODY TEST EFFECT SMASH PROP ARG-TEMPLATE REPEAT EXPR    ;Template things
      PARALLEL-LET ANONYMOUS-BLOCK ORDER ARBITRARY
      BLOCK QUOTE SYMEVAL SET LET DECLARE GO RETURN-FROM        ;Template things that
      EVAL FUNCTION PROG RETURN COND LOOP                ; are already global
      FORM-NOT-UNDERSTOOD                        ;Condition
      *MAPFORMS-BOUND-VARIABLES* *MAPFORMS-BLOCK-NAMES*        ;Variables
      *MAPFORMS-GO-TAGS* *MAPFORMS-NON-FORM-KINDS*))

#+EXPLORER
(DEFMACRO ENV-FUNCTIONS (FOO)
  `(CADR ,FOO))

;; The entry functions to this module are MAPFORMS and COPYFORMS
;;  which take a funarg, a form, and keywords, and call the funarg on parts of the form.
;;  MAPFORMS-1 and COPYFORMS-1 may be called from inside the funarg.
;; The ARG-TEMPLATE declaration is used when defining a special form.
;; The MAPFORMS property may be used for complex special forms.
;; Errors detected are of two kinds:
;;  Problems with the form being mapped over signal FORM-NOT-UNDERSTOOD
;;    These errors may always be proceeded and will do something reasonable by default.
;;    This code isn't as careful as it could be about checking for dotted lists in forms.
;;  Bugs in MAPFORMS itself, or in templates, are signalled with ERROR.

;;; KIND
;; A piece of Lisp code has a KIND, saying what it is, independent of context.
;; The following kinds are forms (they get evaluated):
;;    QUOTE - a constant (whether quoted or self-evaluating or same-evaluating)
;;        i.e. this form is guaranteed always to evaluate the same no
;;        matter how many times and in what context you evaluate it
;;    SYMEVAL - a variable reference
;;    a list - a function combination of any sort (normal, special, or lambda)
;;      for special forms, the list is non-empty and its cdr is the arg-template
;;        to be matched against the cdr of the form (see next page)
;;      for regular function combinations, the list is NIL
;; The following kinds are not forms:
;;    SET - a variable being setqed
;;    LET - a variable being bound
;;    DECLARE - a local declaration
;;    GO - a prog tag being gone to
;;    RETURN-FROM - a block name (prog name) being returned from
;;    ARBITRARY - an arbitrary side-effect not associated with any particular piece
;;        of Lisp code.  The code passed is just the name of the special form involved.

;;; USAGE
;; The context of a piece of Lisp code is described by a usage symbol.
;; These are the usages that the MAPFORMS funarg will see.  The somewhat
;; similar usages used in arg templates are described on the next page.
;;
;; The following usages imply evaluation, and tell something about how the result
;; of the evaluation is used:
;;    EVAL - general case
;;    TEST - all that matters is whether the value is NIL
;;    EFFECT - the value is not used
;;    SMASH - the resulting object is modified (e.g. NREVERSE)
;;    PROP - the result is used as a property name
;;    FUNCTION - the result is used as a function
;;  more of these are likely to be added in the future; unrecognized usages should be
;;  assumed to imply evaluation
;;--- SMASH and PROP templates have not been put in on the many functions that would
;;--- need them.  Interlisp seems to find these useful; we could put them in someday.
;;  The KIND of a form used with one of the above usages will necessarily be
;;  one of the "form" kinds: QUOTE, SYMEVAL, or a list.
;;
;; The following usages do not imply evaluation, hence don't go with forms:
;;    QUOTE - a subform that is not evaluated
;;    SET - a variable being setq'ed
;;    LET - a variable being bound
;;    SYMEVAL - a variable used as a variable (but not a form)
;;    CALL - a function (typically inside of #')
;;    GO - a prog tag being gone to
;;    RETURN-FROM - a block name being returned from
;;    DECLARE - a local declaration
;;    ARBITRARY - some arbitrary side-effect is occurring, not associated
;;            with a particular form.  The piece of Lisp code
;;            is the name of the special form involved.
;; Each of the above non-form usages has a characteristic KIND that goes with
;; it.  This is the same symbol, except for CALL where the KIND is QUOTE.

;;; ARG-TEMPLATE declaration
;;
;; An argument template is a tree which is matched against the cdr of a form.
;; Leaves of the tree are symbols or lists with special symbols in their car,
;; and usually match forms to be evaluated (sometimes they match special syntactic
;; things).  The leaves define where the forms to be evaluated are and also
;; something about how the arguments are used.  Thus many of the symbols that
;; may be used as leaves are the same as the USAGE symbols listed above.
;;
;; Possible leaves are:
;;    QUOTE - this expression is not evaluated
;;    SET - a variable appearing here is setqed
;;    LET - a variable appearing here is bound (a list is a variable and a value)
;;    PARALLEL-LET - like ((REPEAT LET)) but the bindings are done in parallel
;;    SYMEVAL - a variable appearing here is used as a variable (but is not a form)
;;    CALL - this expression is not evaluated, but if it is a function it is called
;;    BODY - any number of expressions, all but the last for effect ("progn")
;;    DECLARE - any number of local declarations and documentation strings may appear here
;;      (the funarg sees single declarations with a usage of DECLARE)
;;     PROG - prog tags and forms evaluated for effect (a prog body)
;;    GO - this expression is not evaluated (it's a prog tag being gone to)
;;    RETURN-FROM - this expression is not evaluated (it's a block name being returned from)
;;    BLOCK - this expression is not evaluated (it's a block name being defined)
;;    EVAL - a form is evaluated
;;    TEST - a form is evaluated, but all that matters is whether the value is NIL
;;    EFFECT - a form is evaluated, but its value is not used
;;     RETURN - a form is evaluated, and its value is also the value of the whole form
;;    SMASH - a form is evaluated and the resulting object is modified (e.g. NREVERSE)
;;    PROP - a form is evaluated and the result is used as a property name
;;    FUNCTION - a form is evaluated and the result is used as a function
;;    ARBITRARY - does not match any subform; indicates that an arbitrary
;;        side-effect occurs at this point.  This is an "escape hatch"
;;        for special forms that don't fit in to the model very well.
;;   The next three are attributes of the whole form and don't match any subforms
;;   These must appear at the front of a template
;;    COND - this form is a conditional; it doesn't necessarily evaluate all its subforms.
;;    LOOP - this form is an iteration; it may evaluate some subforms no or multiple times.
;;     ANONYMOUS-BLOCK - indicates an unnamed prog
;;   The remaining leaves are "complex".
;;    REPEAT and ORDER match multiple subforms, the others match one.
;;    (REPEAT template template...) - the sequence of templates is repeated zero
;;        or more times, to match the length of the form
;;    (IF predicate true-template false-template) - use predicate to decide
;;        which template to use.  If predicate is atomic, it is a function
;;        applied to the matching expression, otherwise it is a form to
;;        to evaluate with EXPR bound to the matching expression.
;;    (ORDER (n template) (n template)...) - the next several subforms are matched
;;        to the templates in order.  But the order of evaluation (and hence
;;        of mapforms processing) is not left-to-right, but is according
;;        to increasing numerical order of the numbers "n".
;;        By special hair, one of the templates may be a REPEAT.
;;   The following two can really screw things up when the correspondence between
;;   what is analyzed and the original code matters.  Fortunately they aren't
;;   used currently.  They come from Interlisp.
;;    (AND template template...) - all of the templates specified apply
;;        this causes the matching expression to be analyzed multiple times
;;    (MACRO expr template) - expr and template are forms to be evaluated,
;;        with EXPR bound to the matching expression.  Use the results as
;;        the new matching expression and the new template.
;;  more of these are likely to be added in the future; unrecognized symbols should be
;;  assumed to imply evaluation
;;
;; Error if the form is longer than the template, but not vice versa (optional args).
;;
;; Example declaration for COND:
;;    (DECLARE (ARG-TEMPLATE COND (REPEAT (TEST . BODY))))
;; For IF (with multi-else feature):
;;    (DECLARE (ARG-TEMPLATE COND TEST RETURN . BODY))

(DEFPROP ARG-TEMPLATE T COMPILER:DEBUG-INFO)

;;; The following variables are likely to be used by the user.

;;; This variable contains a list of the variables bound around the current form
;;; or the symbol NO-ENV if we were not asked to keep track of that
(DEFVAR *MAPFORMS-BOUND-VARIABLES*)

;;; If bound variables maintained, this list of block names extant is maintained
(DEFVAR *MAPFORMS-BLOCK-NAMES*)

;;; If bound variables maintained, this list of go tags extant is maintained
(DEFVAR *MAPFORMS-GO-TAGS*)

;;; The KIND symbols that correspond to non-form Lisp code fragments
(DEFPARAMETER *MAPFORMS-NON-FORM-KINDS* '(SET LET DECLARE GO RETURN-FROM ARBITRARY))

;;; Also LOCAL-DECLARATIONS will be bound appropriately for any local
;;; DECLAREs that are encountered.

;;; The user may call back into MAPFORMS-1 or COPYFORMS-1 when bypassing
;;; normal processing.  Don't forget to return a second value of T.

;;; Mapforms/Copyforms top level

;;; This variable is an a-list of arg-templates, for those which for whatever
;;; reason are not in the function's debugging info.
(DEFVAR *ARG-TEMPLATE-ALIST* NIL)

;;; The following variables are bound at entry to MAPFORMS or COPYFORMS

;;; This variable contains an a-list of the block names defined around the current form.
;;; The cdr of each entry is the USAGE of that block.
;;; This list is a stack list, and hence must not be squirelled away
(DEFVAR *MAPFORMS-BLOCK-ALIST*)

(DEFVAR *MAPFORMS-FUNCTION*)            ;Function being mapped
(DEFVAR *MAPFORMS-STATE*)            ;Holds state returned by user function
(DEFVAR *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*);An interpreter environment
                        ;for tracking MACROLET's and FLET's
(DEFVAR *COPYFORMS-FLAG*)            ;T if copying/transforming subforms
(DEFVAR *MAPFORMS-APPLY-FUNCTION*)        ;Post-processing function
(DEFVAR *MAPFORMS-ITERATION-HOOK*)        ;:ITERATION-HOOK function
(DEFVAR *MAPFORMS-EXPAND-SUBSTS*)        ;:EXPAND-SUBSTS flag
(DEFVAR *MAPFORMS-PARALLEL-BINDS*)        ;Side-effect from MAPFORMS-BIND
(DEFVAR *COPYFORMS-EXPAND-ALL-MACROS* NIL)    ;T to copy macro expansions
        ;(needs a top-level value, but it doesn't matter what it is!)


(DEFUN MAPFORMS (*MAPFORMS-FUNCTION* FORM
         &KEY (INITIAL-STATE NIL)
              (BOUND-VARIABLES 'NO-ENV)
              (USAGE 'EVAL)
              (APPLY-FUNCTION NIL)
              (ITERATION-HOOK NIL)
              (EXPAND-SUBSTS NIL)
         &AUX (*COPYFORMS-FLAG* NIL)
              (*MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT* NIL)
              (*MAPFORMS-BOUND-VARIABLES* BOUND-VARIABLES)
              (*MAPFORMS-ITERATION-HOOK* ITERATION-HOOK)
              (*MAPFORMS-EXPAND-SUBSTS* EXPAND-SUBSTS)
              (*MAPFORMS-BLOCK-NAMES* NIL)
              (*MAPFORMS-GO-TAGS* NIL)
              (*MAPFORMS-BLOCK-ALIST* NIL)
              (*MAPFORMS-APPLY-FUNCTION* APPLY-FUNCTION)
              (*MAPFORMS-STATE* INITIAL-STATE))
  (DECLARE (SYS:DOWNWARD-FUNARG *MAPFORMS-FUNCTION*))
  "Call a function on a form and all of its subforms.
  The function is called on arguments subform, kind, usage, and state,
and its first returned value is the new state.  If the second value is
non-NIL the normal processing of this form is to be suppressed.
  STATE is initially NIL unless the :INITIAL-STATE option is specified;
the final state is returned as the value of MAPFORMS.
  KIND is a symbol or list describing the subform (which can be a form or a
variable being setq'ed or bound).
  USAGE is a symbol describing the context in which the subform appears.
The :USAGE option, defaulting to EVAL, is the usage for the top-level form.
  If the :BOUND-VARIABLES option is specified, it is the initial value
\(usually NIL) for *MAPFORMS-BOUND-VARIABLES*, the list of variables
bound around the evaluation of each form.  If :BOUND-VARIABLES is not
specified, the bookkeeping for bound variables is suppressed.
  If the :APPLY-FUNCTION option is specified, it is a function called
with the same arguments and values as the main processing function.  It sees
each non-atomic form after its arguments or subforms have been processed.
  If the :ITERATION-HOOK option is specified, it is a function called with
an argument of T when an iteration is entered and NIL when it is left.
  If the :EXPAND-SUBSTS option is specified, we look inside DEFSUBST bodies.
Normally they are just assumed to behave like functions."
  (COPYFORMS-1 FORM USAGE)
  *MAPFORMS-STATE*)

(DEFUN COPYFORMS (*MAPFORMS-FUNCTION* FORM
          &KEY (BOUND-VARIABLES 'NO-ENV)
               (USAGE 'EVAL)
               (APPLY-FUNCTION NIL)
               (ITERATION-HOOK NIL)
               (EXPAND-SUBSTS NIL)
               (EXPAND-ALL-MACROS NIL)
          &AUX (*COPYFORMS-FLAG* T)
               (*MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT* NIL)
               (*MAPFORMS-APPLY-FUNCTION* APPLY-FUNCTION)
               (*MAPFORMS-ITERATION-HOOK* ITERATION-HOOK)
               (*MAPFORMS-EXPAND-SUBSTS* EXPAND-SUBSTS)
               (*MAPFORMS-BOUND-VARIABLES* BOUND-VARIABLES)
               (*MAPFORMS-BLOCK-NAMES* NIL)
               (*MAPFORMS-GO-TAGS* NIL)
               (*MAPFORMS-BLOCK-ALIST* NIL)
               (*COPYFORMS-EXPAND-ALL-MACROS* EXPAND-ALL-MACROS))
  "Call a function on a form and all its subforms, possibly making
substitutions.  The function is called on arguments subform, kind, and usage,
and its returned value replaces the subform if it is not EQ.  If the second
value is non-NIL the normal processing of this form is to be suppressed.
Structure is copied as necessary to avoid smashing any of the original form.
  KIND is a symbol or list describing the subform (which can be a form or a variable
being setq'ed or bound).
  USAGE is a symbol describing the context in which the subform appears.  The
:USAGE option, defaulting to EVAL, is the usage for the top-level form.
  If the :EXPAND-ALL-MACROS option is specified, macro-expansions will
be copied into the result.  Otherwise, the original macro form will
remain, unless something in the expansion was modified during copying.
  If the :BOUND-VARIABLES option is specified, it is the initial value
\(usually NIL) for *MAPFORMS-BOUND-VARIABLES*, the list of variables
bound around the evaluation of each form.  If :BOUND-VARIABLES is not
specified, the bookkeeping for bound variables is suppressed.
  If the :APPLY-FUNCTION option is specified, it is a function called
with the same arguments and values as the main processing function.  It sees
each non-atomic form after its arguments or subforms have been processed.
If it substitutes a new form, the new form will be analyzed and copied.
  If the :ITERATION-HOOK option is specified, it is a function called with
an argument of T when an iteration is entered and NIL when it is left."
  (COPYFORMS-1 FORM USAGE))

;;; Supporting macros

;;; This macro allows substituting for some element of a list being
;;; mapped down, without smashing anything yet with minimal consing.
;;;    ORIGINAL-LIST - the original, uncopied list
;;;    CURRENT-LIST - that or a copy of it (must be a variable)
;;;    TAIL - must be a tail of CURRENT-LIST, its car is to be changed
;;; If TAIL is a variable, it is setq'ed to the corresponding tail of
;;; the copy if a copy is made.
(DEFMACRO MAPFORMS-RPLACA (ORIGINAL-LIST CURRENT-LIST TAIL NEWCAR)
  (OR (SYMBOLP CURRENT-LIST) (ERROR "~S not a variable" CURRENT-LIST))
  (ONCE-ONLY (NEWCAR)
    `(COND ((NEQ (CAR ,TAIL) ,NEWCAR)
        (RPLACA (IF (EQ ,ORIGINAL-LIST ,CURRENT-LIST)
            (MULTIPLE-VALUE-SETQ (,(AND (SYMBOLP TAIL) TAIL) ,CURRENT-LIST)
              (MAPFORMS-RPLACA-COPY ,TAIL ,CURRENT-LIST))
            ,TAIL)
            ,NEWCAR)))))

(DEFUN MAPFORMS-RPLACA-COPY (TAIL LIST)
  (LOOP WITH NEW-LIST = (COPY-LIST LIST)
    FOR NEW-TAIL ON NEW-LIST AND OLD-TAIL ON LIST
    WHEN (EQ OLD-TAIL TAIL)
      RETURN (VALUES NEW-TAIL NEW-LIST)
    FINALLY (ERROR "~S is not a tail of ~S" TAIL LIST)))

;;; Same for cdr.
;;; Never stores back into TAIL (since of course it doesn't copy list beyond it)
;;; We assume that a given tail will only be rplacd'ed once
(DEFMACRO MAPFORMS-RPLACD (ORIGINAL-LIST CURRENT-LIST TAIL NEWCDR)
  (OR (SYMBOLP CURRENT-LIST) (ERROR "~S not a variable" CURRENT-LIST))
  (ONCE-ONLY (NEWCDR)
    `(COND ((NEQ (CDR ,TAIL) ,NEWCDR)
        (RPLACD (IF (EQ ,ORIGINAL-LIST ,CURRENT-LIST)
            (MULTIPLE-VALUE-SETQ (NIL ,CURRENT-LIST)
              (MAPFORMS-RPLACD-COPY ,TAIL ,CURRENT-LIST))
            ,TAIL)
            ,NEWCDR)))))

;Copy list through tail, but not into (cdr tail)
(DEFUN MAPFORMS-RPLACD-COPY (TAIL LIST)
  (LET* ((ORIGINAL-TAIL TAIL)
     (ORIGINAL-LIST LIST)
     (NEW-HEAD (CONS (CAR LIST) NIL))
     (NEW-TAIL NEW-HEAD))
    (LOOP DO
      (WHEN (ATOM LIST)
    (ERROR "~S is not a tail of ~S" ORIGINAL-TAIL ORIGINAL-LIST))
      (RPLACD NEW-TAIL (CDR LIST))
      (WHEN (EQ LIST TAIL)
    (RETURN (VALUES NEW-TAIL NEW-HEAD)))
      (SETQ LIST (CDR LIST))
      (RPLACD NEW-TAIL (SETQ NEW-TAIL (CONS (CAR LIST) NIL))))))

;;; Determine the KIND of a form (see the first page)
;;; As a second value we may return one of
;;;    LAMBDA - a lambda combination
;;;    NAMED-LAMBDA - a named-lambda combination
;;;    MACRO - a macro combination (for which there is no arg-template)
;;;    LAMBDA-MACRO - a lambda-macro combination
;;;    SYMBOL-MACRO - a symbol macro
;;;    SUBST - a defsubst (when checking for them is enabled)
;;;    some other atom - a special processing function, obtained from the
;;;      property of the function name whose indicator is our second argument
(DEFUN CLASSIFY-FORM (FORM PROPERTY &AUX FCN TEM)
  (DECLARE (VALUES KIND SPECIAL))
  (COND ((ATOM FORM)
     (COND ((CONSTANTP FORM)
        'QUOTE)
           ((PROPERTYP FORM 'SYMBOL-MACRO)
        (VALUES NIL 'SYMBOL-MACRO))
           ((PROPERTYP FORM 'ATOMIC-MACRO)    ;Old name
        (VALUES NIL 'SYMBOL-MACRO))
           (T 'SYMEVAL)))
    ((EQ (SETQ FCN (CAR FORM)) 'QUOTE)
     'QUOTE)
    ((SYMBOLP FCN)
     (COND ((SETQ TEM (CADR (ASSOC FCN (ENV-FUNCTIONS
                        *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*) :TEST #'EQ)))    ;second el of env is for functions
        (COND ((EQ (CAR TEM) 'SPECIAL)
               (VALUES NIL 'MACRO))
              (T NIL)))
           ((NOT (FBOUNDP FCN))
        NIL)
           ((OR #| (SETQ TEM (ASSOC 'ARG-TEMPLATE (DEBUGGING-INFO FCN))) |#
            (SETQ TEM (ASSOC FCN *ARG-TEMPLATE-ALIST*)))
        (VALUES TEM (AND PROPERTY (GET FCN PROPERTY))))
           ((MACRO-FUNCTION FCN)
        (VALUES NIL 'MACRO))
           #| ((AND *MAPFORMS-EXPAND-SUBSTS*
             (ASSOC 'SUBST-DEFINITION (DEBUGGING-INFO FCN)))
        (VALUES NIL 'SUBST)) |#
           ((FUNCTIONP FCN NIL)
        NIL)
           ((AND PROPERTY (SETQ TEM (GET FCN PROPERTY)))
        (VALUES NIL TEM))
           (T (FORM-NOT-UNDERSTOOD FORM "~S is a special form but lacks an arg-template"
                        FCN)
          NIL)))
    ((AND (LISTP FCN) (MEMBER (CAR FCN) '(LAMBDA SUBST)))
     (VALUES NIL 'LAMBDA))
    ((AND (LISTP FCN) (MEMBER (CAR FCN) '(NAMED-LAMBDA NAMED-SUBST)))
     (VALUES NIL 'NAMED-LAMBDA))
    #|((LAMBDA-MACRO-CALL-P FCN)
     (VALUES NIL 'LAMBDA-MACRO))|#
    (T (FORM-NOT-UNDERSTOOD FORM "~S not understood in the function position of a form"
                     FCN)
       NIL)))

;Not necessarily self-evaluating.  Just guaranteed always to evaluate to the same thing.
;--- Note that, unlike the compiler, we assume that defconstant's are not allowed
;--- to be shadowed by lexical or instance variables.  Common Lisp seems to allow
;--- such shadowing, except that since there is no unspecial declaration it is
;--- impossible to do, and it seems to discourage it by saying that the compiler
;--- may warn.  I would check for it here, but the environment is not available.
;--- In any case the CL CONSTANTP function is required to be true of such symbols.
#-EXPLORER
(DEFUN CONSTANTP (OBJECT)
  (IF (ATOM OBJECT)
      (OR (NOT (SYMBOLP OBJECT))
      (NULL OBJECT)
      (EQ OBJECT T)
      (GET OBJECT 'DEFCONSTANT)
      (KEYWORDP OBJECT))
      (EQ (CAR OBJECT) 'QUOTE)))

(DEFUN VARIABLEP (X)
  (AND (SYMBOLP X)
       (NOT (CONSTANTP X))            ;better in Common Lisp
       (NOT (PROPERTYP X 'SYMBOL-MACRO))
       (NOT (PROPERTYP X 'ATOMIC-MACRO))    ;old name
       ))

;GET-PROPERTIES is an absolutely miserable replacement for GETL
(DEFUN PROPERTYP (SYMBOL INDICATOR)
  (LOOP FOR (I V) ON (SYMBOL-PLIST SYMBOL) BY 'CDDR
    THEREIS (EQ I INDICATOR)))

;;; Main driving functions

;;; Process a form and its subforms, and return the new form
;;; (If not COPYFORMS, return the original form)
;;; The user function may call back into this if doing a COPYFORMS
(DEFUN COPYFORMS-1 (ORIGINAL-FORM &OPTIONAL (USAGE 'EVAL))
  ;; Loop as long as new forms are substituted
  (LOOP WITH (KIND SPECIAL)
    WITH FORM = ORIGINAL-FORM
    WITH ORIGINAL-BEFORE-MACRO-EXPANSION = ORIGINAL-FORM
    WITH DONE-FLAG        ;Flags considered harmful: used for two purposes, too!
    WITH NEW-FORM DO
    (MULTIPLE-VALUE-SETQ (KIND SPECIAL) (CLASSIFY-FORM FORM 'MAPFORMS))
    ;; Tell the client about this form.
    ;; It may replace the form or override normal subform processing.
    (MULTIPLE-VALUE-SETQ (NEW-FORM DONE-FLAG) (MAPFORMS-CALL FORM KIND USAGE))
    ;; Process the form accordingly, and set DONE-FLAG if loop should terminate
    (COND ((NEQ NEW-FORM FORM) (SETQ FORM NEW-FORM))    ;Again, with substituted form
      (DONE-FLAG)                    ;Bypass normal processing
      ((OR (EQ SPECIAL 'MACRO)            ;Any kind of macro
           #|(EQ SPECIAL 'LAMBDA-MACRO)|#
           (EQ SPECIAL 'SYMBOL-MACRO)
           (EQ SPECIAL 'SUBST))
       (LET ((EXPANSION (CASE SPECIAL
                  ((MACRO SYMBOL-MACRO SUBST)
                   (MACROEXPAND-1 FORM *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*))
                  #|(LAMBDA-MACRO
                (CONS (LAMBDA-MACRO-EXPAND (CAR FORM)) (CDR FORM)))|#)))
         (AND (EQ ORIGINAL-FORM FORM)
          (SETQ ORIGINAL-FORM EXPANSION))
         (SETQ FORM EXPANSION)))
      ((OR (EQ SPECIAL 'LAMBDA) (EQ SPECIAL 'NAMED-LAMBDA))    ;Lambda-combination
       (LET ((LAMBDA-LIST (IF (EQ SPECIAL 'NAMED-LAMBDA) (CDDAR FORM) (CDAR FORM))))
         ;; Check for lambda-list keywords that would mean abnormal argument evaluation.
         (IF (MEMBER '"E LAMBDA-LIST)
         (FORM-NOT-UNDERSTOOD FORM ""E appears in the lambda list"))
         ;; First process the arguments.
         (SETQ FORM (MAPFORMS-LIST ORIGINAL-FORM FORM (CDR FORM) 'EVAL 'EVAL))
         ;; Now process the bindings and then the body
         (MAPFORMS-RPLACA ORIGINAL-FORM FORM
                  FORM (MAPFORMS-LAMBDA (CAR FORM) (CAR FORM) LAMBDA-LIST USAGE))
         (SETQ DONE-FLAG T)))
      (SPECIAL                    ;General escape
       (SETQ FORM (FUNCALL SPECIAL ORIGINAL-FORM FORM USAGE))
       (SETQ DONE-FLAG T))
      ((NULL KIND)                    ;Ordinary function, do args
       (SETQ FORM (MAPFORMS-LIST ORIGINAL-FORM FORM (CDR FORM) 'EVAL 'EVAL))
       (SETQ DONE-FLAG T))
      ((LISTP KIND)                    ;Template-driven meta-eval
       (LET ((TEMPLATE (CDR KIND)))
         (AND (LISTP TEMPLATE)
          (MEMBER (CAR TEMPLATE) '(COND LOOP))
          (SETQ TEMPLATE (CDR TEMPLATE)))    ;Remove flags uninteresting here
         (SETQ FORM (MAPFORMS-TEMPLATE ORIGINAL-FORM FORM TEMPLATE USAGE))
         (SETQ DONE-FLAG T)))
      (T (SETQ DONE-FLAG T)))            ;No subforms
    ;; Now decide whether to return what we have or process it again
    (AND DONE-FLAG
     (OR (ATOM FORM)
         (NULL *MAPFORMS-APPLY-FUNCTION*)
         (EQ FORM (SETQ FORM
                (MULTIPLE-VALUE-SETQ (NIL DONE-FLAG)
                  (MAPFORMS-CALL FORM KIND USAGE *MAPFORMS-APPLY-FUNCTION*))))
         DONE-FLAG)
     (RETURN (IF (AND (EQ FORM ORIGINAL-FORM)
              (NOT *COPYFORMS-EXPAND-ALL-MACROS*))
             ORIGINAL-BEFORE-MACRO-EXPANSION    ;Undo uninteresting macro expansion
             FORM)))))                ;Replacement or original form

;;; The user function may call back into this if doing a MAPFORMS
(DEFUN MAPFORMS-1 (FORM &OPTIONAL (USAGE 'EVAL))
  (COPYFORMS-1 FORM USAGE)
  *MAPFORMS-STATE*)

;;; Call the user function on this form, and return the new form
(DEFUN MAPFORMS-CALL (FORM KIND USAGE &OPTIONAL (FUNCTION *MAPFORMS-FUNCTION*) &AUX FLAG)
  (COND (*COPYFORMS-FLAG*
     (FUNCALL FUNCTION FORM KIND USAGE))
    (T
     (MULTIPLE-VALUE-SETQ (*MAPFORMS-STATE* FLAG)
       (FUNCALL FUNCTION FORM KIND USAGE *MAPFORMS-STATE*))
     (VALUES FORM FLAG))))

;;; Process the rest of the forms in a list.  Return the original list or a copy
;;; of it with substitutions made.
(DEFUN MAPFORMS-LIST (ORIGINAL-LIST CURRENT-LIST TAIL-TO-DO ALL-BUT-LAST-USAGE LAST-USAGE)
  (LOOP FOR TAIL ON TAIL-TO-DO DO
    (MAPFORMS-RPLACA ORIGINAL-LIST CURRENT-LIST
        TAIL (COPYFORMS-1 (CAR TAIL) (IF (CDR TAIL) ALL-BUT-LAST-USAGE LAST-USAGE))))
  CURRENT-LIST)

;;; Pass over documentation strings and local declarations, and return three values:
;;;    New value of CURRENT-LIST
;;;    New value of TAIL
;;;    New value of LOCAL-DECLARATIONS
(DEFUN MAPFORMS-DECLARE (ORIGINAL-LIST CURRENT-LIST TAIL &AUX (DECLARATIONS NIL))
  (LOOP DOING
    (COND ((NULL TAIL) (RETURN))
      ((AND (CDR TAIL) (STRINGP (CAR TAIL))))    ;Doc string
      ((AND (LISTP (CAR TAIL)) (EQ (CAAR TAIL) 'DECLARE))
       (LOOP WITH ORIGINAL = (CAR TAIL)        ;Map over each declaration
         WITH CURRENT = ORIGINAL
         FOR DCLS ON (CDR ORIGINAL)
         DO (MAPFORMS-RPLACA ORIGINAL CURRENT
                     DCLS (MAPFORMS-CALL (CAR DCLS) 'DECLARE 'DECLARE))
         FINALLY (MAPFORMS-RPLACA ORIGINAL-LIST CURRENT-LIST TAIL CURRENT)
             (SETQ DECLARATIONS (APPEND (CDR CURRENT) DECLARATIONS))))
      (T (RETURN)))                    ;Start of real body
    (POP TAIL))
  (VALUES CURRENT-LIST TAIL (NCONC DECLARATIONS LOCAL-DECLARATIONS)))

;;; Process a lambda-expression, or any function body
(DEFUN MAPFORMS-LAMBDA (ORIGINAL-LAMBDA LAMBDA ARGS-AND-BODY USAGE)
  (LET ((*MAPFORMS-BOUND-VARIABLES* *MAPFORMS-BOUND-VARIABLES*))
    (MULTIPLE-VALUE-BIND (LAMBDA ARGS-AND-BODY LOCAL-DECLARATIONS)
    (MAPFORMS-DECLARE ORIGINAL-LAMBDA LAMBDA ARGS-AND-BODY)
      (MAPFORMS-RPLACA ORIGINAL-LAMBDA LAMBDA ARGS-AND-BODY
    (LOOP WITH LAMBDA-LIST = (CAR ARGS-AND-BODY)
          WITH ORIGINAL-LAMBDA-LIST = LAMBDA-LIST
          FOR LL ON LAMBDA-LIST
          DO (OR (MEMBER (CAR LL) LAMBDA-LIST-KEYWORDS)
             (MAPFORMS-RPLACA ORIGINAL-LAMBDA-LIST LAMBDA-LIST
                      LL (MAPFORMS-BIND (CAR LL) NIL T LAMBDA)))
          FINALLY (RETURN LAMBDA-LIST)))
      (MAPFORMS-LIST ORIGINAL-LAMBDA LAMBDA (CDR ARGS-AND-BODY) 'EFFECT USAGE))))

;; Process a single binding
;; which may be VAR, (VAR), or (VAR VAL)
;; ALLOW-SUPPLIED-P is NIL normally
;;               T to allow (var val flag-var)
;;               IGNORE to allow (var val . anything)
;;--- Doesn't handle separate LOCAL-DECLARATIONS for the variable and the init form
(DEFUN MAPFORMS-BIND (BIND PARALLEL-BINDING-P ALLOW-SUPPLIED-P CONTAINING-FORM
              &AUX (ORIGINAL-BIND BIND) (VAR1 NIL) (VAR2 NIL))
  (COND ((SYMBOLP BIND)
     (SETQ BIND (SETQ VAR1 (MAPFORMS-CALL BIND 'LET 'LET))))
    ((ATOM BIND)
     (FORM-NOT-UNDERSTOOD CONTAINING-FORM
                  "~S appears where a bound variable should be" BIND))
    ((NOT (SYMBOLP (CAR BIND)))
     (FORM-NOT-UNDERSTOOD CONTAINING-FORM
                  "~S appears where a bound variable should be" (CAR BIND)))
    (T
     (MAPFORMS-RPLACA ORIGINAL-BIND BIND
              BIND (SETQ VAR1 (MAPFORMS-CALL (CAR BIND) 'LET 'LET)))
     (WHEN (CDR BIND)
       ;; Init form or default value for optional argument
       (MAPFORMS-RPLACA ORIGINAL-BIND BIND (CDR BIND) (COPYFORMS-1 (CADR BIND) 'EVAL))
       (COND ((NULL (CDDR BIND)))
         ((OR (CDDDR BIND) (NOT ALLOW-SUPPLIED-P))
          (FORM-NOT-UNDERSTOOD CONTAINING-FORM
                       "~S is too long to be a list of variable and value"
                       BIND))
         ((EQ ALLOW-SUPPLIED-P 'IGNORE))
         ((NOT (SYMBOLP (CADDR BIND)))
          (FORM-NOT-UNDERSTOOD CONTAINING-FORM
                       "~S appears where a supplied-p variable should be"
                       (CADDR BIND)))
         (T ;; Optional argument supplied-p-flag variable
          (MAPFORMS-RPLACA ORIGINAL-BIND BIND (CDDR BIND)
                   (SETQ VAR2 (MAPFORMS-CALL (CADDR BIND) 'LET 'LET))))))))
  (COND ((EQ *MAPFORMS-BOUND-VARIABLES* 'NO-ENV))
    (PARALLEL-BINDING-P
     (AND VAR1 (PUSH VAR1 *MAPFORMS-PARALLEL-BINDS*))
     (AND VAR2 (PUSH VAR2 *MAPFORMS-PARALLEL-BINDS*)))
    (T
     (AND VAR1 (PUSH VAR1 *MAPFORMS-BOUND-VARIABLES*))
     (AND VAR2 (PUSH VAR2 *MAPFORMS-BOUND-VARIABLES*))))
  BIND)

;;; Template-directed driving function

(DEFVAR *MAPFORMS-TEMPLATE-USAGE*)    ;USAGE of the whole form being processed
(DEFVAR *MAPFORMS-TEMPLATE-FORM*)    ;Original of the whole form

(DEFUN MAPFORMS-TEMPLATE (ORIGINAL-FORM *MAPFORMS-TEMPLATE-FORM*
              TEMPLATE *MAPFORMS-TEMPLATE-USAGE*)
  (MAPFORMS-RPLACD ORIGINAL-FORM *MAPFORMS-TEMPLATE-FORM*
    *MAPFORMS-TEMPLATE-FORM*
    (LET ((*MAPFORMS-BOUND-VARIABLES* *MAPFORMS-BOUND-VARIABLES*)
          (LOCAL-DECLARATIONS LOCAL-DECLARATIONS))
      (MAPFORMS-TEMPLATE-1 (CDR *MAPFORMS-TEMPLATE-FORM*) TEMPLATE)))
  *MAPFORMS-TEMPLATE-FORM*)

;;; May return a modified version of ARGL, which the caller rplac's into his (sub)form
;;; This function is recursive in the car direction and iterative in the cdr
;;; ARGL is some piece of the original form (initially the cdr), not necessarily a list
(DEFUN MAPFORMS-TEMPLATE-1 (ORIGINAL-ARGL TEMPLATE)
  (LOOP WITH CURRENT-ARGL = ORIGINAL-ARGL
    WITH TAIL = NIL
    WITH ARGL = ORIGINAL-ARGL DO
    (COND ((NULL TEMPLATE)
       (IF ARGL
           (FORM-NOT-UNDERSTOOD *MAPFORMS-TEMPLATE-FORM*
                    "~S are extra arguments not allowed for by the template"
                    ARGL))
       (LOOP-FINISH))

      ;; The following template items match single subforms
      ((MEMBER TEMPLATE '(QUOTE GO RETURN-FROM SET SYMEVAL))
       (SETQ ARGL (MAPFORMS-CALL ARGL TEMPLATE TEMPLATE))
       (LOOP-FINISH))
      ((EQ TEMPLATE 'LET)
       (SETQ ARGL (MAPFORMS-BIND ARGL NIL NIL *MAPFORMS-TEMPLATE-FORM*))
       (LOOP-FINISH))
      ((EQ TEMPLATE 'PARALLEL-LET)
       (LET ((*MAPFORMS-PARALLEL-BINDS* NIL))
         (LOOP WHILE ARGL DO
           (MAPFORMS-RPLACA ORIGINAL-ARGL CURRENT-ARGL ARGL
                (MAPFORMS-BIND (CAR ARGL) T NIL *MAPFORMS-TEMPLATE-FORM*))
           (SETQ TAIL ARGL ARGL (CDR ARGL)))
         (SETQ *MAPFORMS-BOUND-VARIABLES*
           (NCONC *MAPFORMS-PARALLEL-BINDS* *MAPFORMS-BOUND-VARIABLES*)))
       (LOOP-FINISH))
      ((EQ TEMPLATE 'CALL)
       (SETQ ARGL (MAPFORMS-CALL ARGL 'QUOTE TEMPLATE))
       (LOOP-FINISH))
      ((ATOM TEMPLATE)
       (CASE TEMPLATE
         ((BODY)
          (RETURN (MAPFORMS-LIST ORIGINAL-ARGL CURRENT-ARGL
                     ARGL 'EFFECT *MAPFORMS-TEMPLATE-USAGE*)))
         ((PROG)
          (LET ((*MAPFORMS-GO-TAGS*
              (AND (NEQ *MAPFORMS-BOUND-VARIABLES* 'NO-ENV)
               (NCONC (LOOP FOR STMT IN ARGL
                    WHEN (ATOM STMT) COLLECT STMT)
                  *MAPFORMS-GO-TAGS*)))
            (ITERATION NIL))
        (LOOP FOR TAIL ON ARGL AS STMT = (CAR TAIL) DO
          (IF (ATOM STMT)
              ;; First tag is start of possibly iterated code
              ;; We aren't smart enough to worry about tags reached
              ;; only by forward branches.
              (UNLESS ITERATION
            (WHEN *MAPFORMS-ITERATION-HOOK*
              (FUNCALL *MAPFORMS-ITERATION-HOOK* T))
            (SETQ ITERATION T))
              ;; Lists are forms evaluated for effect
              (MAPFORMS-RPLACA ORIGINAL-ARGL CURRENT-ARGL
                       TAIL (COPYFORMS-1 STMT 'EFFECT))))
        (AND ITERATION
             *MAPFORMS-ITERATION-HOOK*
             (FUNCALL *MAPFORMS-ITERATION-HOOK* NIL))
        (RETURN CURRENT-ARGL)))
         ((RETURN)
          (SETQ ARGL (COPYFORMS-1 ARGL *MAPFORMS-TEMPLATE-USAGE*))
          (LOOP-FINISH))
         ((EVAL TEST EFFECT SMASH PROP FUNCTION)
          (SETQ ARGL (COPYFORMS-1 ARGL TEMPLATE))
          (LOOP-FINISH))
         (OTHERWISE
          (ERROR "Malformed template: ~S trying to match ~S in a ~S-form"
             TEMPLATE ARGL (CAR *MAPFORMS-TEMPLATE-FORM*)))))
      ((EQ (CAR TEMPLATE) 'AND)
       (DOLIST (TEMPLATE (CDR TEMPLATE))
         (SETQ ARGL (MAPFORMS-TEMPLATE-1 ARGL TEMPLATE)))
       (LOOP-FINISH))
      ((EQ (CAR TEMPLATE) 'IF)
       (SETQ ARGL (MAPFORMS-TEMPLATE-1 ARGL
            (IF (IF (ATOM (SECOND TEMPLATE)) (FUNCALL (SECOND TEMPLATE) ARGL)
                (LET ((EXPR ARGL))
                  (DECLARE (SPECIAL EXPR))
                  (EVAL (SECOND TEMPLATE))))
                (THIRD TEMPLATE)
                (FOURTH TEMPLATE))))
       (LOOP-FINISH))
      ((EQ (CAR TEMPLATE) 'MACRO)
       (LET ((EXPR ARGL))
         (DECLARE (SPECIAL EXPR))
         (SETQ ARGL (MAPFORMS-TEMPLATE-1 (EVAL (SECOND TEMPLATE))
                         (EVAL (THIRD TEMPLATE)))))
       (LOOP-FINISH))

      ;; The following template items match a variable number of subforms (or none)
      ;; COND and LOOP should have been POP'ed off before we ever get here
      ((EQ (CAR TEMPLATE) 'DECLARE)
       (MULTIPLE-VALUE-SETQ (CURRENT-ARGL ARGL LOCAL-DECLARATIONS)
         (MAPFORMS-DECLARE ORIGINAL-ARGL CURRENT-ARGL ARGL))
       (SETQ TEMPLATE (CDR TEMPLATE)))
      ((EQ (CAR TEMPLATE) 'BLOCK)
       (MAPFORMS-RPLACD ORIGINAL-ARGL ARGL ARGL
                (MAPFORMS-BLOCK (CAR ARGL) (CDR ARGL) (CDR TEMPLATE)))
       (LOOP-FINISH))
      ((EQ (CAR TEMPLATE) 'ANONYMOUS-BLOCK)
       (SETQ ARGL (MAPFORMS-BLOCK NIL ARGL (CDR TEMPLATE)))
       (LOOP-FINISH))
      ((EQ (CAR TEMPLATE) 'ARBITRARY)
       (MAPFORMS-CALL (CAR *MAPFORMS-TEMPLATE-FORM*) 'ARBITRARY 'ARBITRARY)
       (SETQ TEMPLATE (CDR TEMPLATE)))
      ((NULL ARGL) (LOOP-FINISH))
      ((AND (LISTP (CAR TEMPLATE))
        (EQ (CAAR TEMPLATE) 'REPEAT))
       (LOOP REPEAT (MAPFORMS-REPEAT-CHECK TEMPLATE ARGL (CDAR TEMPLATE)) DO
         (LOOP FOR TEM IN (CDAR TEMPLATE) DO
           (MAPFORMS-RPLACA ORIGINAL-ARGL CURRENT-ARGL
                ARGL (MAPFORMS-TEMPLATE-1 (CAR ARGL) TEM))
           (SETQ TAIL ARGL ARGL (CDR ARGL))))
       (SETQ TEMPLATE (CDR TEMPLATE)))
      ((AND (LISTP (CAR TEMPLATE))
        (EQ (CAAR TEMPLATE) 'ORDER))
       ;; First match up templates with forms, special-casing REPEAT
       ;; Each element of FORMS is a form, or a list of forms to repeat through
       ;; Each element of QUEUE is a list (priority template cons-of-FORMS)
       (LOOP FOR X IN (CDAR TEMPLATE) WITH L = ARGL
         AS N = (FIRST X) AND TEM = (SECOND X)
         COLLECT
           (COND ((AND (LISTP TEM) (EQ (CAR TEM) 'REPEAT))
              (LET ((REPEAT (MAPFORMS-REPEAT-CHECK TEMPLATE ARGL
                                   (CDR TEM) (CDDAR TEMPLATE))))
                (SETQ TEM (CDR X))    ;((REPEAT t t...))
                (LDIFF L (SETQ L (NTHCDR (* REPEAT (LIST-LENGTH (CDAR TEM)))
                             L)))))
             (L (POP L))
             (T (FORM-NOT-UNDERSTOOD *MAPFORMS-TEMPLATE-FORM*
                    "Wrong length list: matching ~S to template ~S"
                    ARGL TEMPLATE)
                NIL))
           INTO FORMS
        COLLECT (LIST N TEM (LAST FORMS)) INTO QUEUE
        FINALLY
        ;; Process the forms and templates in evaluation order
        (LOOP FOR (N TEM FORM-LOC) IN (SORT QUEUE #'< :KEY #'CAR) DO
          (RPLACA FORM-LOC (MAPFORMS-TEMPLATE-1 (CAR FORM-LOC) TEM)))
        ;; Store the resulting forms back into ARGL
        (LOOP FOR (N TEM) IN (CDAR TEMPLATE) AND FORM IN FORMS DO
          (COND ((AND (LISTP TEM) (EQ (CAR TEM) 'REPEAT))
             (DOLIST (FORM FORM)
               (MAPFORMS-RPLACA ORIGINAL-ARGL CURRENT-ARGL ARGL FORM)
               (SETQ TAIL ARGL ARGL (CDR ARGL))))
            (T (MAPFORMS-RPLACA ORIGINAL-ARGL CURRENT-ARGL ARGL FORM)
               (SETQ TAIL ARGL ARGL (CDR ARGL))))))
       (SETQ TEMPLATE (CDR TEMPLATE)))

      ;; Not a leaf.  Destructure into the car and cdr of the trees.
      (T (MAPFORMS-RPLACA ORIGINAL-ARGL CURRENT-ARGL
                  ARGL (MAPFORMS-TEMPLATE-1 (CAR ARGL) (CAR TEMPLATE)))
         (SETQ TAIL ARGL ARGL (CDR ARGL))
         (SETQ TEMPLATE (CDR TEMPLATE))))
    FINALLY (RETURN (COND ((NULL TAIL) ARGL)
              (T (MAPFORMS-RPLACD ORIGINAL-ARGL CURRENT-ARGL TAIL ARGL)
                 CURRENT-ARGL)))))

;;; Call the template processor inside a binding of *MAPFORMS-BLOCK-ALIST*
;;; with a new pair on the front.
(DEFUN MAPFORMS-BLOCK (NAME BODY TEMPLATE)
  (WITH-STACK-LIST* (PAIR NAME *MAPFORMS-TEMPLATE-USAGE*)
    (WITH-STACK-LIST* (*MAPFORMS-BLOCK-ALIST* PAIR *MAPFORMS-BLOCK-ALIST*)
      (LET ((*MAPFORMS-BLOCK-NAMES* (AND (NEQ *MAPFORMS-BOUND-VARIABLES* 'NO-ENV)
                     (CONS NAME *MAPFORMS-BLOCK-NAMES*))))
    (MAPFORMS-TEMPLATE-1 BODY TEMPLATE)))))

;;; Decide how much of the form a REPEAT should match (return number of repetitions)
(DEFUN MAPFORMS-REPEAT-CHECK (TEMPLATE ARGL SUBTEMPLATE &OPTIONAL MORE-TEMPLATE)
  ;; Some error checking because these templates are so hairy
  (DOLIST (HAIR '(DECLARE BLOCK ANONYMOUS-BLOCK LOOP COND ARBITRARY))
    (AND (MEMBER HAIR (CDR TEMPLATE))
     (ERROR "Malformed template for ~S: ~S can't figure out how ~@
         much of ~S to match because there is a ~S to its right."
        (CAR *MAPFORMS-TEMPLATE-FORM*) (CAAR TEMPLATE) ARGL HAIR)))
  (DOLIST (HAIR '(REPEAT ORDER))
    (AND (CAREFUL-ASSOC HAIR (CDR TEMPLATE))
     (ERROR "Malformed template for ~S: ~S can't figure out how ~@
         much of ~S to match because there is a ~S to its right."
        (CAR *MAPFORMS-TEMPLATE-FORM*) (CAAR TEMPLATE) ARGL HAIR)))
  (DOLIST (HAIR '(DECLARE BLOCK ANONYMOUS-BLOCK LOOP COND ARBITRARY))
    (AND (MEMBER HAIR SUBTEMPLATE)
     (ERROR "Malformed template for ~S: ~S can't figure out how ~@
         much of ~S to match because there is a ~S in the repeated part."
        (CAR *MAPFORMS-TEMPLATE-FORM*) (CAAR TEMPLATE) ARGL HAIR)))
  (DOLIST (HAIR '(REPEAT ORDER))
    (AND (CAREFUL-ASSOC HAIR SUBTEMPLATE)
     (ERROR "Malformed template for ~S: ~S can't figure out how ~@
         much of ~S to match because there is a ~S in the repeated part."
        (CAR *MAPFORMS-TEMPLATE-FORM*) (CAAR TEMPLATE) ARGL HAIR)))
  ;; Decide number of repetitions
  (LET ((TLEN (LIST-LENGTH SUBTEMPLATE))    ;Number of repeated items
    (LEN (- (LIST-LENGTH ARGL)        ;Number of matching args
        (LIST-LENGTH (CDR TEMPLATE))
        (LIST-LENGTH MORE-TEMPLATE))))
    (OR (ZEROP (MOD LEN TLEN))
    (FORM-NOT-UNDERSTOOD *MAPFORMS-TEMPLATE-FORM*
                 "Wrong length list: matching ~S to template ~S leaves ~D extra"
                 ARGL TEMPLATE (MOD LEN TLEN)))
    (FLOOR LEN TLEN)))

;I can't use any Common Lisp functions for this, because L may be a "dotted"
;list rather than a true list.
(DEFUN CAREFUL-ASSOC (X L)
  (DO ((L L (CDR L)))
      ((ATOM L) NIL)
    (AND (LISTP (CAR L))
     (EQL (CAAR L) X)
     (RETURN (CAR L)))))

;;; Error reporting

#+LISPM (PROGN 'COMPILE        ;Common Lisp doesn't have conditions yet

;Flavor definition put first to defeat signal compiler warning
(DEFFLAVOR FORM-NOT-UNDERSTOOD (FORM FORMAT-STRING FORMAT-ARGS COPYFORMS-FLAG)
       (DBG:NO-ACTION-MIXIN ZL:ERROR)
  (:INITABLE-INSTANCE-VARIABLES FORM FORMAT-STRING FORMAT-ARGS)
  (:GETTABLE-INSTANCE-VARIABLES FORM))

;All errors are signalled by calling this function, which signals
;the condition of the same name.  Normally goes to the debugger,
;but the caller of MAPFORMS may establish a handler.
;This function might work differently in other Lisp implementations.
(DEFUN FORM-NOT-UNDERSTOOD (FORM FORMAT-STRING &REST FORMAT-ARGS)
  (SIGNAL 'FORM-NOT-UNDERSTOOD :FORM FORM
                   :FORMAT-STRING FORMAT-STRING
                   :FORMAT-ARGS (COPY-LIST FORMAT-ARGS)
                   :PROCEED-TYPES '(:NO-ACTION)))

(DEFPROP FORM-NOT-UNDERSTOOD T :ERROR-REPORTER)

(DEFMETHOD (FORM-NOT-UNDERSTOOD :AFTER :INIT) (IGNORE)
  (SETQ COPYFORMS-FLAG *COPYFORMS-FLAG*))

(DEFMETHOD (FORM-NOT-UNDERSTOOD :REPORT) (STREAM)
  (FORMAT STREAM "~:[MAPFORMS~;COPYFORMS~] was unable to understand the form ~S.~%~1{~}"
      COPYFORMS-FLAG FORM FORMAT-STRING FORMAT-ARGS))

(COMPILE-FLAVOR-METHODS FORM-NOT-UNDERSTOOD)
);#+LISPM

#-LISPM                ;This will work in straight Common Lisp
(DEFUN FORM-NOT-UNDERSTOOD (FORM FORMAT-STRING &REST FORMAT-ARGS)
  (ERROR "~:[MAPFORMS~;COPYFORMS~] was unable to understand the form ~S.~%~1{~}"
      COPYFORMS-FLAG FORM FORMAT-STRING FORMAT-ARGS))

;;; Knowledge of special forms that has to be procedural

(DEFUN (:PROPERTY MACROLET MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (WITH-STACK-LIST (*MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*
             NIL (ENV-FUNCTIONS *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*))
    ;; I think it is improper to walk the expanders --BSG
    (LOOP FOR MACRO IN (CADR FORM)
      DO (PUSH (MACROEXPAND MACRO *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*)
           (ENV-FUNCTIONS *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*)))
    (MAPFORMS-LIST ORIGINAL-FORM FORM (CDDR FORM) 'EFFECT USAGE)))

(DEFUN (:PROPERTY FLET MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-FLET-LABELS ORIGINAL-FORM FORM USAGE))

(DEFUN (:PROPERTY LABELS MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-FLET-LABELS ORIGINAL-FORM FORM USAGE))

(DEFUN MAPFORMS-FLET-LABELS (ORIGINAL-FORM FORM USAGE)
  (WITH-STACK-LIST (*MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*
             NIL (ENV-FUNCTIONS *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*))
    (FLET ((WALK-DEFINITIONS ()
          (LOOP WITH FUNCL = (CADR FORM)
            WITH CURRENT-FUNCL = FUNCL
            FOR DEFS ON FUNCL
            AS (LAMBDA) = DEFS
            DO (MAPFORMS-RPLACA
             FUNCL CURRENT-FUNCL
             DEFS (MAPFORMS-LAMBDA LAMBDA LAMBDA (CDR LAMBDA) 'EVAL))
            FINALLY  (MAPFORMS-RPLACA ORIGINAL-FORM FORM (CDR FORM) CURRENT-FUNCL)))
       (ADD-DEFINITIONS-TO-ENVIRONMENT ()
              (LOOP FOR (FUNCTION) IN (CADR FORM)
            DO (PUSH (LIST
                   FUNCTION
                   (LIST #'(LAMBDA (&REST IGNORE)
                     (ERROR
                       "Can't call lexical function ~S at compile time."
                       FUNCTION))))    ;Get it?
                 (ENV-FUNCTIONS *MAPFORMS-LEXICAL-FUNCTION-ENVIRONMENT*)))))
      (CASE (CAR ORIGINAL-FORM)
    (LABELS
      (ADD-DEFINITIONS-TO-ENVIRONMENT)
      (WALK-DEFINITIONS))
    (FLET
      (WALK-DEFINITIONS)
      (ADD-DEFINITIONS-TO-ENVIRONMENT))))

    (MAPFORMS-LIST ORIGINAL-FORM FORM (CDDR FORM) 'EFFECT USAGE)))

;Must be procedural to get bindings wrapped around it
(DEFUN (:PROPERTY COMPILER-LET MAPFORMS) (IGNORE FORM USAGE)
  (LET ((NEW-BODY (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) #'COPYFORMS-1 USAGE)))
    ;; If the body was altered, build a new whole form to contain it, else return original
    (IF (NULL (CDDDR FORM))
    (IF (EQ NEW-BODY (CADDR FORM))
        FORM
        `(COMPILER-LET ,(CADR FORM) ,NEW-BODY))
    ;; Take back apart the progn 'compile built by compiler-let-internal
    (COND ((EQ (CDDR NEW-BODY) (CDDR FORM))
           FORM)
          ((AND (LISTP NEW-BODY)
            (EQ (CAR NEW-BODY) 'PROGN)
            (EQUAL (CADR NEW-BODY) ''COMPILE))
           `(COMPILER-LET ,(CADR FORM) . ,(CDDR NEW-BODY)))
          (T `(COMPILER-LET ,(CADR FORM) ,NEW-BODY))))))

;These must be procedural to lookup the usage of the block being returned from
;--- This is the ZL definition of RETURN block lookup, not the CL definition ---
;--- However, that's what the compiler uses.  So how am I confused? ---
(DEFUN (:PROPERTY RETURN MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-CALL NIL 'RETURN-FROM 'RETURN-FROM)
  (SETQ USAGE (LOOP FOR (NAME . USAGE) IN *MAPFORMS-BLOCK-ALIST*
            WHEN (NEQ NAME T) RETURN USAGE
            FINALLY (RETURN 'EVAL)))
  (MAPFORMS-LIST ORIGINAL-FORM FORM (CDR FORM) USAGE USAGE))

(DEFUN (:PROPERTY RETURN-FROM MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-RPLACA ORIGINAL-FORM FORM (CDR FORM)
           (MAPFORMS-CALL (CADR FORM) 'RETURN-FROM 'RETURN-FROM))
  (SETQ USAGE (OR (CDR (ASSOC (CADR FORM) *MAPFORMS-BLOCK-ALIST*)) 'EVAL))
  (MAPFORMS-LIST ORIGINAL-FORM FORM (CDDR FORM) USAGE USAGE))

(DEFUN (:PROPERTY COMPILER:RETURN-FROM-T MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-CALL T 'RETURN-FROM 'RETURN-FROM)
  (SETQ USAGE (OR (CDR (ASSOC T *MAPFORMS-BLOCK-ALIST*)) 'EVAL))
  (MAPFORMS-LIST ORIGINAL-FORM FORM (CDDR FORM) USAGE USAGE))

;The 8 forms/styles of DO must be procedural because it's too hard to
;get the bindings to happen at the right time in a template
;--- Here we include the oldstyle DO from Zetalisp.  What the hell.
(DEFUN (:PROPERTY DO MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-DO ORIGINAL-FORM FORM NIL (CDR FORM) USAGE T))

(DEFUN (:PROPERTY DO* MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-DO ORIGINAL-FORM FORM NIL (CDR FORM) USAGE NIL))

#+LISPM
(DEFUN (:PROPERTY ZL:DO-NAMED MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-DO ORIGINAL-FORM FORM (CADR FORM) (CDDR FORM) USAGE T))

#+LISPM
(DEFUN (:PROPERTY ZL:DO*-NAMED MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-DO ORIGINAL-FORM FORM (CADR FORM) (CDDR FORM) USAGE NIL))

;Doesn't allow for GO/RETURN in the step forms, which the Common Lisp manual says
;is illegal although the example expansion into TAGBODY it gives would allow it.
;This routine puts the block and tag environments around just the body forms.
(DEFUN MAPFORMS-DO (ORIGINAL-FORM CURRENT-FORM BLOCK-NAME TAIL1 USAGE PARALLEL-BINDING-P)
  (LET ((*MAPFORMS-BOUND-VARIABLES* *MAPFORMS-BOUND-VARIABLES*)
    (*MAPFORMS-PARALLEL-BINDS* NIL)
    (LOCAL-DECLARATIONS LOCAL-DECLARATIONS)
    (TAIL TAIL1))
    (IF (LISTP (CAR TAIL))
    ;; New-style DO
    (LET* ((BINDS (POP TAIL))
           (ORIGINAL-BINDS BINDS)
           (ENDCLAUSE (POP TAIL)))
      ;; Process local declarations
      (MULTIPLE-VALUE-SETQ (CURRENT-FORM TAIL LOCAL-DECLARATIONS)
        (MAPFORMS-DECLARE ORIGINAL-FORM CURRENT-FORM TAIL))
      ;; Process bindings of variables to initial values
      (LOOP FOR BINDL ON BINDS DO
        (MAPFORMS-RPLACA ORIGINAL-BINDS BINDS BINDL
             (MAPFORMS-BIND (CAR BINDL) PARALLEL-BINDING-P 'IGNORE ORIGINAL-FORM)))
      ;; Install parallel bindings
      (SETQ *MAPFORMS-BOUND-VARIABLES*
        (NCONC *MAPFORMS-PARALLEL-BINDS* *MAPFORMS-BOUND-VARIABLES*))
      (SETQ *MAPFORMS-PARALLEL-BINDS* NIL)
      ;; Begin iterated section of code, if not a do-once
      ;; All of this code except for the endtest is only conditionally executed
      (AND ENDCLAUSE *MAPFORMS-ITERATION-HOOK*
           (FUNCALL *MAPFORMS-ITERATION-HOOK* T))
      ;; Process the body
      (LET ((*MAPFORMS-TEMPLATE-FORM* CURRENT-FORM)
        (*MAPFORMS-TEMPLATE-USAGE* USAGE))
        (MAPFORMS-RPLACD ORIGINAL-FORM CURRENT-FORM
                 (LOOP FOR RDC ON CURRENT-FORM
                   WHEN (EQ (CDR RDC) TAIL) RETURN RDC)
                 (MAPFORMS-BLOCK BLOCK-NAME TAIL 'PROG)))
      ;; Go back and process step forms
      (LOOP FOR BINDL ON BINDS DO
        (OR (ATOM (CAR BINDL))
        (NULL (CDDAR BINDL))
        (LET ((BIND (CAR BINDL)))
          (MAPFORMS-RPLACA BIND BIND (CDDR BIND) (COPYFORMS-1 (CADDR BIND) 'EVAL))
          (MAPFORMS-RPLACA ORIGINAL-BINDS BINDS BINDL BIND))))
      (MAPFORMS-RPLACA ORIGINAL-FORM CURRENT-FORM TAIL1 BINDS)
      ;; Process the end-test and return values, if not a do-once
      (WHEN ENDCLAUSE
        (MAPFORMS-RPLACA ENDCLAUSE ENDCLAUSE
                 ENDCLAUSE (COPYFORMS-1 (CAR ENDCLAUSE) 'TEST))
        ;; End iterated section of code
        (AND *MAPFORMS-ITERATION-HOOK*
         (FUNCALL *MAPFORMS-ITERATION-HOOK* NIL))
        (MAPFORMS-RPLACA ORIGINAL-FORM CURRENT-FORM (CDR TAIL1)
          (MAPFORMS-LIST (CADR TAIL1) ENDCLAUSE (CDR ENDCLAUSE) 'EFFECT USAGE))))
    ;; Old-style DO
    (LET ((VAR (POP TAIL))
          (INIT (POP TAIL))
          (STEP (POP TAIL))
          (TEST (POP TAIL)))
      ;; Process local declarations
      (MULTIPLE-VALUE-SETQ (CURRENT-FORM TAIL LOCAL-DECLARATIONS)
        (MAPFORMS-DECLARE ORIGINAL-FORM CURRENT-FORM TAIL))
      ;; Process initial value form
      (MAPFORMS-RPLACA ORIGINAL-FORM CURRENT-FORM (CDR TAIL1) (COPYFORMS-1 INIT 'EVAL))
      ;; Bind the variable
      (MAPFORMS-BIND VAR NIL NIL ORIGINAL-FORM)
      ;; Begin iterated section of code
      ;; All of this code except for the endtest is only conditionally executed
      (AND *MAPFORMS-ITERATION-HOOK*
           (FUNCALL *MAPFORMS-ITERATION-HOOK* T))
      ;; Process the body
      (LET ((*MAPFORMS-TEMPLATE-FORM* CURRENT-FORM)
        (*MAPFORMS-TEMPLATE-USAGE* USAGE))
        (MAPFORMS-RPLACD ORIGINAL-FORM CURRENT-FORM
                 (LOOP FOR RDC ON CURRENT-FORM
                   WHEN (EQ (CDR RDC) TAIL) RETURN RDC)
                 (MAPFORMS-BLOCK BLOCK-NAME TAIL 'PROG)))
      ;; Process step form
      (MAPFORMS-RPLACA ORIGINAL-FORM CURRENT-FORM (CDDR TAIL1) (COPYFORMS-1 STEP 'EVAL))
      ;; Process endtest form
      (MAPFORMS-RPLACA ORIGINAL-FORM CURRENT-FORM
               (CDDDR TAIL1) (COPYFORMS-1 TEST 'TEST))
      ;; End iterated section of code
      (AND *MAPFORMS-ITERATION-HOOK*
           (FUNCALL *MAPFORMS-ITERATION-HOOK* NIL))))
    CURRENT-FORM))

#+LISPM        ;--- I don't know what non-LISPM implementations want for this
;Procedural because of DEFUN-COMPATIBILITY and MAPFORMS-LAMBDA
;This is on ZL:DEFUN because CL:DEFUN is a macro
(DEFUN (:PROPERTY ZL:DEFUN MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (LET ((NEW-FORM (SYS:DEFUN-COMPATIBILITY (CDR FORM))))
    (IF (EQ (CDR NEW-FORM) (CDR FORM))
    (MAPFORMS-LAMBDA ORIGINAL-FORM FORM (CDDR FORM) USAGE)
    (COPYFORMS-1 NEW-FORM USAGE))))

;Procedural because of MAPFORMS-LAMBDA
(DEFUN (:PROPERTY MACRO MAPFORMS) (ORIGINAL-FORM FORM USAGE)
  (MAPFORMS-LAMBDA ORIGINAL-FORM FORM (CDDR FORM) USAGE))

;The template is ((REPEAT (ORDER (2 SET) (1 EVAL)))), which is too hard to
;implement nonprocedurally because of the ORDER inside the REPEAT
(DEFUN (:PROPERTY SETQ MAPFORMS) (ORIGINAL-FORM FORM IGNORE)
  (LOOP WITH TAIL = (CDR FORM) WHILE TAIL
    AS NEW-VAL = (COPYFORMS-1 (CADR TAIL) 'EVAL)
    AS NEW-VAR = (MAPFORMS-CALL (CAR TAIL) 'SET 'SET)
    DO (MAPFORMS-RPLACA ORIGINAL-FORM FORM TAIL NEW-VAR)
       (SETQ TAIL (CDR TAIL))
       (MAPFORMS-RPLACA ORIGINAL-FORM FORM TAIL NEW-VAL)
       (SETQ TAIL (CDR TAIL)))
  FORM)

#+EXPLORER
(DEFUN COMPILER-LET-INTERNAL (BINDLIST BODY PROCESSING-FUNCTION &REST ADDITIONAL-ARGS)
  (PROGV (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) BINDLIST)
     (MAPCAR #'(LAMBDA (X) (IF (ATOM X) NIL (EVAL (CADR X)))) BINDLIST)
    (APPLY PROCESSING-FUNCTION
       (IF (CDR BODY)
           `(PROGN . ,BODY)
           (CAR BODY))
       ADDITIONAL-ARGS)))